(*
  octi_rawblas OCaml interface generator
  2008-06-03 FP
*)


(*i*)
let debug = false
(*i*)


(*s The fortran functions. Warning, no spaces around commas *)
(* The  extra arguments gives special caml group and names *)

let input_fundefs = "
S,D           SUBROUTINE xROTG (A,B,C,S)
S,D           SUBROUTINE xROTMG(D1,D2,A,B,PARAM)
S,D           SUBROUTINE xROT  (N,X,INCX,Y,INCY,C,S)
S,D           SUBROUTINE xROTM (N,X,INCX,Y,INCY,PARAM)
S,D,C,Z       SUBROUTINE xSWAP (N,X,INCX,Y,INCY)
S,D,C,Z,CS,ZD SUBROUTINE xSCAL (N,ALPHA,X,INCX)           CSSCAL:C.sscal ZDSCAL:Z.dscal
S,D,C,Z       SUBROUTINE xCOPY (N,X,INCX,Y,INCY)
S,D,C,Z       SUBROUTINE xAXPY (N,ALPHA,X,INCX,Y,INCY)
S,D,DS        FUNCTION   xDOT  (N,X,INCX,Y,INCY)          DSDOT:S.ddot
C,Z           FUNCTION 	 xDOTU (N,X,INCX,Y,INCY)
C,Z           FUNCTION   xDOTC (N,X,INCX,Y,INCY)
S             FUNCTION   xDSDOT(N,X,INCX,Y,INCY)
S,D,SC,DZ     FUNCTION   xNRM2 (N,X,INCX)                 SCNRM2:C.nrm2 DZNRM2:Z.nrm2
S,D,SC,DZ     FUNCTION   xASUM (N,X,INCX)                 SCASUM:C.asum DZASUM:Z.asum
S,D,C,Z       FUNCTION   IxAMAX(N,X,INCX) 
S,D,C,Z       SUBROUTINE xGEMV (TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
S,D,C,Z       SUBROUTINE xGBMV (TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
C,Z           SUBROUTINE xHEMV (UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
C,Z           SUBROUTINE xHBMV (UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
C,Z           SUBROUTINE xHPMV (UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
S,D           SUBROUTINE xSYMV (UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
S,D           SUBROUTINE xSBMV (UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
S,D           SUBROUTINE xSPMV (UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
S,D,C,Z       SUBROUTINE xTRMV (UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
S,D,C,Z       SUBROUTINE xTBMV (UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
S,D,C,Z       SUBROUTINE xTPMV (UPLO,TRANS,DIAG,N,AP,X,INCX)
S,D,C,Z       SUBROUTINE xTRSV (UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
S,D,C,Z       SUBROUTINE xTBSV (UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
S,D,C,Z       SUBROUTINE xTPSV (UPLO,TRANS,DIAG,N,AP,X,INCX)
S,D           SUBROUTINE xGER  (M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
C,Z           SUBROUTINE xGERU (M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
C,Z           SUBROUTINE xGERC (M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
C,Z           SUBROUTINE xHER  (UPLO,N,ALPHA,X,INCX,A,LDA)
C,Z           SUBROUTINE xHPR  (UPLO,N,ALPHA,X,INCX,AP)
C,Z           SUBROUTINE xHER2 (UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
C,Z           SUBROUTINE xHPR2 (UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
S,D           SUBROUTINE xSYR  (UPLO,N,ALPHA,X,INCX,A,LDA)
S,D           SUBROUTINE xSPR  (UPLO,N,ALPHA,X,INCX,AP)
S,D           SUBROUTINE xSYR2 (UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
S,D           SUBROUTINE xSPR2 (UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
S,D,C,Z       SUBROUTINE xGEMM (TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
S,D,C,Z       SUBROUTINE xSYMM (SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
C,Z           SUBROUTINE xHEMM (SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
S,D,C,Z       SUBROUTINE xSYRK (UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
C,Z           SUBROUTINE xHERK (UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
S,D,C,Z       SUBROUTINE xSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
C,Z           SUBROUTINE xHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
S,D,C,Z       SUBROUTINE xTRMM (SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
S,D,C,Z       SUBROUTINE xTRSM (SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
"

    
(*s
  argument types
  t is pointer on SDCZ type
  T is value SDCZ type
*)
    
let input_argums = "
A      IO t
ALPHA  I  T CSSCAL:S ZDSCAL:D
AP     I  t
BETA   I  T
B      IO t
C      IO t
D1     IO t
D2     IO t
DIAG   I  CHAR
INCX   I  I
INCY   I  I
INFO    O I
IPIV    O I
K      I  I
KL     I  I
KU     I  I
LDA    I  I
LDB    I  I
LDC    I  I
M      I  I
N      I  I
NRHS   I  I
PARAM  I  t 
S       O t
SIDE   I  CHAR
TRANS  I  CHAR
TRANSA I  CHAR
TRANSB I  CHAR
UPLO   I  CHAR
X      IO t CSSCAL:C ZDSCAL:Z DSDOT:S SCNRM2:C DZNRM2:Z SCASUM:C DZASUM:Z
Y      IO t                   DSDOT:S
ret     O T                   DSDOT:D SCNRM2:S DZNRM2:D SCASUM:S DZASUM:D ISAMAX:I IDAMAX:I ICAMAX:I IZAMAX:I
"

module Utils =
struct
  
  (* some utilities *)
  
  module Map_over_strings = Map.Make (String)
    
  let puts l = print_string (l ^ "\n")
    
  (*s split functions *)
    
  let split_newline = Str.split (Str.regexp "[\n]") (* skips starting and ending void lines *)
  let split_comma = Str.split (Str.regexp "[,]")
  let split_spaces = Str.split (Str.regexp "[ \t]+")
    
  (*s "foo:bar" -> ("foo","bar") *)
    
  exception Not_a_comma_pair of string
    
  let split_column_pair p =
    match Str.split (Str.regexp "[:]") p with
      | [a;b] -> (a,b)
      | _ -> raise (Not_a_comma_pair p)
	  
  (*s "foo.bar" -> ("foo","bar") *)
	  
  exception Not_a_dot_pair of string
    
  let split_dot_pair p =
    match Str.split (Str.regexp "[.]") p with
      | [a;b] ->
	  (a,b)
      | _ -> raise (Not_a_dot_pair p)
end
  
  
module Fundef =
struct
  let read _ = (input_fundefs, Utils.split_newline input_argums)
    
  type complex_calling_convention = Hidden_argument | Standard_return 
      (* On systems based on IA-32 architecture, Fortran functions of type COMPLEX place a hidden COMPLEX argument at the beginning of the argument list. C functions that implement such a call from Fortran must declare this hidden argument explicitly, and use it to return a value. The C return type should be void. *)
      
  let complex_calling_convention  = Hidden_argument
end

module Bg =
struct
  type group_type = S_group | D_group | C_group | Z_group
  type type_type = S_type | D_type | C_type | Z_type | I_type | CHAR_type
      
  type return_type = SUBROUTINE | FUNCTION of type_type
  type argum_type = VALUE of type_type | POINTER of type_type
    
  exception Bad_function_match of string 
    
  type stub_funs = ONE_STUB of string | TWO_STUBS of (string * string)
end

module Bg1 = 
struct
  (*s regexps for functions and arguments lists *)
  
  let (rfundefs, rargums) =
    let bo = "[ \t]+"
    and bf = "[ \t]*"
    and v = "\\([^ \t]+\\)"
    in
      (Str.regexp ("^" ^ bf ^ v ^ bo ^ v ^ bo ^ v ^ bf ^ "(" ^ v ^ ")" ^ "\\(.*\\)$"),
       Str.regexp ("^" ^ bf ^ v ^ bo ^ v ^ bo ^ v ^ "\\(.*\\)$"))
	
  (*s How to interpret a function line *)
  (* 
     let (prefixes_list, subroutine_or_function, fname, argum_list, map_of_specials) =
     get_fundef "S,D,C,Z,CS,ZD SUBROUTINE xSCAL (N,ALPHA,X,INCX) CSSCAL:C.sscal ZDSCAL:Z.dscal";;
     let _ = Map_over_strings.iter (fun key value -> print_string ("  " ^ key ^ " -> (" ^ (fst value) ^ ", " ^ (snd value) ^ ")\n")) map_of_specials;;
     
     "S,D,C,Z,CS,ZD SUBROUTINE xSCAL (N,ALPHA,X,INCX) CSSCAL:C.sscal ZDSCAL:Z.dscal"
     
     val prefixes_list          : string list = ["S"; "D"; "C"; "Z"; "CS"; "ZD"]
     val subroutine_or_function : string      = "SUBROUTINE"
     val fname                  : string      = "xSCAL"
     val argum_list             : string list = ["N"; "ALPHA"; "X"; "INCX"]
     val map_of_specials        : (string * string) Map_over_strings.t = <abstr>
     CSSCAL -> (C, sscal)
     ZDSCAL -> (Z, dscal)
     
  *)
	
	
  exception Bad_line of string
    
  let get_fundef l =
    let (prefixes, subrouf, fname, args, specials) =
      if Str.string_match rfundefs l 0 then
	begin
	  (*i print_string (Str.matched_group 0 l);
	    print_newline ();i*)
	  (Str.matched_group 1 l, Str.matched_group 2 l, Str.matched_group 3 l, Str.matched_group 4 l, Str.matched_group 5 l)
	end
      else
	raise (Bad_line l)
    in
    let add_special m special =
      let (f,s) = Utils.split_column_pair special
      in Utils.Map_over_strings.add f (Utils.split_dot_pair s) m
    in
      (Utils.split_comma prefixes, subrouf, fname, Utils.split_comma args,
       List.fold_left add_special Utils.Map_over_strings.empty (Utils.split_spaces specials)
      )
	
	
  let make_fundef_list input_fundefs = List.map get_fundef (Utils.split_newline input_fundefs)
    
  (**
     Now we have "psfas_list". Each "psfas" corresponds to one line of "input_fundefs".
     Hence it contains  	prefix_list, subroutine_or_function, function_name, argum_list
     and a map of special returns 
  *)
    
    
  (*s How to interpret an argument line *)
    
  let add_argum m l =
    let (argum, io, kind, specials) =
      if Str.string_match rargums l 0 then
	(Str.matched_group 1 l, Str.matched_group 2 l, Str.matched_group 3 l, Str.matched_group 4 l)
      else
	raise (Bad_line l)
    in
    let add_special m special =
      let (f,t) = Utils.split_column_pair special
      in Utils.Map_over_strings.add f t m
    in
      (* puts argum; *)
      Utils.Map_over_strings.add argum (io, kind, List.fold_left add_special Utils.Map_over_strings.empty (Utils.split_spaces specials)) m
	
  let make_argum_map input_argums = List.fold_left add_argum Utils.Map_over_strings.empty input_argums

end

module Debug_bg1 =
struct
  let pring_argum_map argum_map =
    let prikv1 k1 v1 =
      print_string ("\",\n        \"" ^ k1 ^ "\" -> \"" ^ v1)
    in
    let pritri (i_or_o,argum_type,specials_map) =
      print_string ("    (\"" ^ i_or_o ^ "\", \"" ^ argum_type);
      Utils.Map_over_strings.iter prikv1 specials_map;
      print_string "\")\n"
    in
    let prikv2 argum_name v2 =
      print_string ("  \"" ^ argum_name ^ "\" ->\n");
      pritri v2
    in Utils.Map_over_strings.iter prikv2 argum_map
end

module Control =
struct
  (*s An helper explaining that an argument definition is missing *)
  
  exception Missing_argum of string
    
  (*s The test over all the functions *)
    
  let get_argum_data m k =
    try Utils.Map_over_strings.find k m
    with Not_found -> raise (Missing_argum k)  
      
  let test_fun_for_argums argum_map (p,s,f,a,specials) =
    let test_argum k =
      let _ = get_argum_data argum_map k in ()
    in
      List.iter test_argum a
	
  let control_argums psfas_list argum_map =
    List.iter (test_fun_for_argums argum_map) psfas_list
      
end

module Bg2 =
struct
  exception Not_a_subroutine_nor_a_function of string
    
  exception Bad_xname of string
    
  exception No_group_type_for_string of string
    
  let group_of_string p =
    match p with
      | "S" -> Bg.S_group
      | "D" -> Bg.D_group
      | "C" -> Bg.C_group
      | "Z" -> Bg.Z_group
      | _ -> raise (No_group_type_for_string p)
	  
  exception No_val_type_for_string of string
    
  let type_of_string p =
    match p with
      | "S" -> Bg.S_type
      | "D" -> Bg.D_type
      | "C" -> Bg.C_type
      | "Z" -> Bg.Z_type
      | "I" -> Bg.I_type
      | "CHAR" -> Bg.CHAR_type
      | _ -> raise (No_val_type_for_string p)
	  
	  
  (** Returns the return type
      ex:
      [get_ret_type] DS DSDOT -> [D_type], because of {DSDOT:D SCNRM2:S DZNRM2:D ...}
  *)
	  
  let get_ret_type argum_map p fn =
    let (_, _, specials) = Utils.Map_over_strings.find "ret" argum_map
    in
    let np =
      try Utils.Map_over_strings.find fn specials
      with Not_found -> p
    in
      (type_of_string np)
	
  (** Gives the type of the argument
      ex:
      [get_argum_type] CS X CSSCAL -> POINTER [C_type]
  *)
	
  let get_argum_type argum_map p a fn =
    let (io, t, specials) = Utils.Map_over_strings.find a argum_map
    in
    let (ispointer, t) =
      match (io, t) with
	| (_,"t") -> (true, p)
	| (_,"T") -> (false, p)
	| ("I",fixed) -> (false, fixed)
	| ("O",fixed) -> (true, fixed)
	| ("IO",fixed) -> (true, fixed)
	| (other,_) -> raise (Invalid_argument other)
    in
    let t =
      try Utils.Map_over_strings.find fn specials
      with Not_found -> t
    in
      if ispointer then
	Bg.POINTER (type_of_string t)
      else
	Bg.VALUE (type_of_string t)
	  
  (** Gives the name and the type of the argument
      ex:
      [get_argum_type] CS CSSCAL X -> (x, POINTER [C_type])
  *)
	  
  let get_argum_name_and_type argum_map p fn a =
    (* Utils.puts (fn ^ "(" ^ a ^ ")"); *)
    (String.lowercase a, get_argum_type argum_map p a fn)
      
      
      
  (** Create a list of structures
      ex:
      [function_structure_of_psfas] (["S";"D"], "SUBROUTINE", "xROTG", ["A";"B";"C";"S"])
      -> [(SROTM, (S_group, rotm), SUBROUTINE, [(A,POINTER S);...]);
      (DROTM, (D_group, rotm), SUBROUTINE, [(A,POINTER D);...])]
      other case                   FUNCTION [D_type]
  *)
      
      
  let function_structure_of_psfas argum_map (pl,s,f,al,specials) =
    (** Returns the OCaml module and function names
	ex: 
	special\_caml\_name CSSCAL CS SCAL {CSSCAL:C.sscal ZDSCAL:Z.dscal} -> (D_group, sscal)
	special\_caml\_name ZSCAL Z SCAL {...} -> (Z\_group, scal)
    *) 
    
    let special_caml_name a_fortran_name a_p a_sf a_specials =
      let (l_p, l_sf) =
	if Utils.Map_over_strings.mem a_fortran_name a_specials then
	  Utils.Map_over_strings.find a_fortran_name a_specials
	else
	  (a_p, String.lowercase a_sf)
      in
	(group_of_string l_p, l_sf)
    in
      
    (** Returns the fortran name and the OCaml module and function names
	ex:
	[get_function_names] D xROTM {...} -> (DROTM, ([D_group], rotm))
	[get_function_names] CS xSCAL {CSSCAL:C.sscal ZDSCAL:Z.dscal} -> (CSSCAL, ([D_group], sscal))
    *)
    let get_function_names a_p a_f a_specials =
      let (l_fsf, l_osf) =
	if String.get a_f 0 = 'x' then
	  let l_sf = String.sub a_f 1 ((String.length a_f) - 1)
	  in 
	    (a_p ^ l_sf, l_sf)
	else if String.get a_f 1 = 'x' then
	  let l_sf1 = String.sub a_f 0 1
	  and l_sf2 = String.sub a_f 2 ((String.length a_f) - 2)
	  in
	    (l_sf1 ^ a_p ^ l_sf2, l_sf1 ^ l_sf2)
	else
	  raise (Bad_xname a_f)
      in
	(l_fsf, special_caml_name l_fsf a_p l_osf a_specials)
    in
    let compute_structure p =
      let (fn, on) = get_function_names p f specials
      in
      let st = match s with
	| "SUBROUTINE" -> Bg.SUBROUTINE
	| "FUNCTION" -> Bg.FUNCTION (get_ret_type argum_map p fn)
	| _ -> raise (Not_a_subroutine_nor_a_function s)
      in
	(fn, on, st, List.map (get_argum_name_and_type argum_map p fn) al)
    in
      List.map compute_structure pl
	
  (** Create list of all structures like
      (SROTM, ([S_group], rotm), SUBROUTINE, [(A,POINTER S);...])
  *)
	
  let make_function_structures_list argum_map psfas_list =
    List.concat (List.map (function_structure_of_psfas argum_map) psfas_list)
end


module Pseudo =
struct
  exception Bad_function_match of string 
    
  let construct_function (fortran_name,
			  (ocaml_group, ocaml_name),
			  sub_or_fun,
			  argum_list) =
    Utils.puts "";
    Utils.puts ("fortran name   = " ^ fortran_name);
    let gn = match ocaml_group with
      | Bg.S_group -> "S."
      | Bg.D_group -> "D."
      | Bg.C_group -> "C."
      | Bg.Z_group -> "Z."
    and put_argum (name, t) =
      let type_string = match t with
	| Bg.POINTER Bg.S_type -> " *S"
	| Bg.POINTER Bg.D_type -> " *D"
	| Bg.POINTER Bg.C_type -> " *C"
	| Bg.POINTER Bg.Z_type -> " *Z"
	| Bg.POINTER Bg.I_type -> " *I"
	| Bg.VALUE Bg.S_type -> " S"
	| Bg.VALUE Bg.D_type -> " D"
	| Bg.VALUE Bg.C_type -> " C"
	| Bg.VALUE Bg.Z_type -> " Z"
	| Bg.VALUE Bg.I_type -> " I"
	| Bg.VALUE Bg.CHAR_type -> " CHAR"
	| _ -> raise (Bad_function_match "POINTER or VALUE ???")
      in Utils.puts ("           " ^ name ^ type_string)
    and put_ret sub_or_fun =
      match sub_or_fun with
	| Bg.SUBROUTINE -> Utils.puts "return type    = void"
	| Bg.FUNCTION Bg.S_type -> Utils.puts "return type    = S"
	| Bg.FUNCTION Bg.D_type -> Utils.puts "return type    = D"
	| Bg.FUNCTION Bg.C_type -> Utils.puts "return type    = C"
	| Bg.FUNCTION Bg.Z_type -> Utils.puts "return type    = Z"
	| Bg.FUNCTION Bg.I_type -> Utils.puts "return type    = I"
	| Bg.FUNCTION _ -> raise (Bad_function_match "FUNCTION ???")
    in
      put_ret sub_or_fun;
      Utils.puts ("ocaml function = " ^ gn ^ ocaml_name);
      Utils.puts "arguments:";
      List.iter put_argum argum_list
	
  let out function_structures_list =
    List.iter construct_function function_structures_list
end

 
module C_argument_declaration =
struct
  exception Bad_function_match of string 
    
  let of_argum (n, t) =
    match t with
      | Bg.POINTER Bg.S_type  -> "float * " ^ n
      | Bg.POINTER Bg.D_type  -> "double * " ^ n
      | Bg.POINTER Bg.C_type  -> "float * " ^ n
      | Bg.POINTER Bg.Z_type  -> "double * " ^ n
      | Bg.POINTER Bg.I_type  -> "int * " ^ n
      | Bg.VALUE Bg.S_type    -> "const float * " ^ n
      | Bg.VALUE Bg.D_type    -> "const double * " ^ n
      | Bg.VALUE Bg.C_type    -> "const float * " ^ n
      | Bg.VALUE Bg.Z_type    -> "const double * " ^ n
      | Bg.VALUE Bg.I_type    -> "const int * " ^ n
      | Bg.VALUE Bg.CHAR_type -> "const char * " ^ n
      | _ -> raise (Bad_function_match "POINTER or VALUE ???") 	  
	  
  let append fortran_argum nt =
    (if (String.length fortran_argum <> 0) then fortran_argum ^ ", " else "") ^ (of_argum nt)
      
end
module C_extern_declare =
struct

  exception Bad_function_match of string 
    
  let make_fortran_argum argums_list =
    List.fold_left C_argument_declaration.append "" argums_list
      
  let out_hidden_argument return_type c_name argums_list =
    let rts =
      match return_type with
	| Bg.SUBROUTINE -> "void"
	| Bg.FUNCTION Bg.S_type -> "float"
	| Bg.FUNCTION Bg.D_type -> "double"
	| Bg.FUNCTION Bg.C_type -> "void /* IA-32 */"
	| Bg.FUNCTION Bg.Z_type -> "void /* IA-32 */"
	| Bg.FUNCTION Bg.I_type -> "int"
	| Bg.FUNCTION _ -> raise (Bad_function_match "Bg.FUNCTION ???")
    and xca = (* extra complex argum *)
      match return_type with
	| Bg.SUBROUTINE -> ""
	| Bg.FUNCTION Bg.S_type -> ""
	| Bg.FUNCTION Bg.D_type -> ""
	| Bg.FUNCTION Bg.C_type -> "_Complex float * /* IA-32 */, "
	| Bg.FUNCTION Bg.Z_type -> "_Complex double * /* IA-32 */, "
	| Bg.FUNCTION Bg.I_type -> ""
	| Bg.FUNCTION _ -> raise (Bad_function_match "Bg.FUNCTION ???")
    in  "\nextern " ^ rts ^ " " ^ c_name ^ "_ (" ^ xca ^ (make_fortran_argum argums_list) ^ ");\n"
	  
  let out_standard_return  return_type fortran_name argums_list =
    raise (Failure "out_standard_return not implemented yet")
      
  let out return_type fortran_name argums_list =
    let c_name = (String.lowercase fortran_name)
    in
      match Fundef.complex_calling_convention with
	| Fundef.Hidden_argument -> out_hidden_argument return_type c_name argums_list
	| Fundef.Standard_return -> out_standard_return return_type c_name argums_list
	    
end
  
module Ocaml_argument =
struct
  exception Bad_function_match of string 
    
  let of_type t =
    match t with
      | Bg.POINTER Bg.S_type  -> "Octi_rawb.Bytes.t"
      | Bg.POINTER Bg.D_type  -> "Octi_rawb.Bytes.t"
      | Bg.POINTER Bg.C_type  -> "Octi_rawb.Bytes.t"
      | Bg.POINTER Bg.Z_type  -> "Octi_rawb.Bytes.t"
      | Bg.POINTER Bg.I_type  -> "Octi_rawb.Bytes.t"
      | Bg.VALUE Bg.S_type    -> "float"
      | Bg.VALUE Bg.D_type    -> "float"
      | Bg.VALUE Bg.C_type    -> "Complex.t"
      | Bg.VALUE Bg.Z_type    -> "Complex.t"
      | Bg.VALUE Bg.I_type    -> "int"
      | Bg.VALUE Bg.CHAR_type -> "int"
      | _ -> raise (Bad_function_match "POINTER or VALUE ???") 
	  
  let append ocaml_argum nt =
    ocaml_argum ^ " " ^ (of_type (snd nt)) ^ " ->"   
end
 
module C_value_declaration =
struct
  exception Bad_function_match of string 
    
  let of_argum (n, t) =
    match t with
      | Bg.POINTER Bg.S_type  -> "struct octi_rawb_bytes * " ^ n
      | Bg.POINTER Bg.D_type  -> "struct octi_rawb_bytes * " ^ n
      | Bg.POINTER Bg.C_type  -> "struct octi_rawb_bytes * " ^ n
      | Bg.POINTER Bg.Z_type  -> "struct octi_rawb_bytes * " ^ n
      | Bg.POINTER Bg.I_type  -> "struct octi_rawb_bytes * " ^ n
      | Bg.VALUE Bg.S_type    -> "float "                    ^ n
      | Bg.VALUE Bg.D_type    -> "double "                   ^ n
      | Bg.VALUE Bg.C_type    -> "float "                    ^ n ^ "[2]"
      | Bg.VALUE Bg.Z_type    -> "double "                   ^ n ^ "[2]"
      | Bg.VALUE Bg.I_type    -> "int "                      ^ n
      | Bg.VALUE Bg.CHAR_type -> "char "                     ^ n
      | _ -> raise (Bad_function_match "POINTER or VALUE ???") 
	  
  let append c_declare nt =
    c_declare ^ "        " ^ (of_argum nt) ^ ";\n"
      
end

module C_assignment =
struct
  exception Bad_function_match of string 
    
  let of_argum (n, t) =
    match t with
      | Bg.POINTER Bg.S_type  -> n ^ " = Octi_rawb_bytes_val (v_" ^ n ^ ")"
      | Bg.POINTER Bg.D_type  -> n ^ " = Octi_rawb_bytes_val (v_" ^ n ^ ")"
      | Bg.POINTER Bg.C_type  -> n ^ " = Octi_rawb_bytes_val (v_" ^ n ^ ")"
      | Bg.POINTER Bg.Z_type  -> n ^ " = Octi_rawb_bytes_val (v_" ^ n ^ ")"
      | Bg.POINTER Bg.I_type  -> n ^ " = Octi_rawb_bytes_val (v_" ^ n ^ ")"
      | Bg.VALUE   Bg.S_type  -> n ^ " = Double_val (v_" ^ n ^ ")"
      | Bg.VALUE   Bg.D_type  -> n ^ " = Double_val (v_" ^ n ^ ")"
      | Bg.VALUE   Bg.C_type  -> n ^ "[0] = Double_field(v_" ^ n ^ ", 0); " ^ n ^ "[1] = Double_field(v_" ^ n ^ ", 1)"
      | Bg.VALUE   Bg.Z_type  -> n ^ "[0] = Double_field(v_" ^ n ^ ", 0); " ^ n ^ "[1] = Double_field(v_" ^ n ^ ", 1)"
      | Bg.VALUE   Bg.I_type  -> n ^ " = Int_val (v_" ^ n ^ ")"
      | Bg.VALUE   Bg.CHAR_type -> n ^ " = (char) Int_val (v_" ^ n ^ ")"
      | _ -> raise (Bad_function_match "POINTER or VALUE ???") 
	  
  let append c_assign nt =
    c_assign  ^ "        " ^ (of_argum nt) ^ ";\n"
      
end

module C_call =
struct
  exception Bad_function_match of string 
    
  let of_argum (n, t) =
    match t with
      | Bg.POINTER Bg.S_type  -> n ^ "->bytes"
      | Bg.POINTER Bg.D_type  -> n ^ "->bytes"
      | Bg.POINTER Bg.C_type  -> n ^ "->bytes"
      | Bg.POINTER Bg.Z_type  -> n ^ "->bytes"
      | Bg.POINTER Bg.I_type  -> n ^ "->bytes"
      | Bg.VALUE Bg.S_type    -> "&" ^ n
      | Bg.VALUE Bg.D_type    -> "&" ^ n
      | Bg.VALUE Bg.C_type    -> n
      | Bg.VALUE Bg.Z_type    -> n
      | Bg.VALUE Bg.I_type    -> "&" ^ n
      | Bg.VALUE Bg.CHAR_type -> "&" ^ n
      | _ -> raise (Bad_function_match "POINTER or VALUE ???") 	  
	  
  let append c_call nt =
    (if (String.length c_call <> 0) then c_call ^ ", " else "") ^ (of_argum nt)
      
      
  let pretty_void c_name c_call  =
    "        " ^ c_name ^ " " ^ "(" ^ c_call ^ ");\n"
      
  let pretty_standard c_name c_call  =
    "        result = " ^ c_name ^ " " ^ "(" ^ c_call ^ ");\n"
      
  let pretty_hidden_argum c_name c_call  =
    "        " ^ c_name ^ " " ^ "(&result, " ^ c_call ^ ");\n"
      
  let pretty_complex c_name c_call  =
    match Fundef.complex_calling_convention with
      | Fundef.Hidden_argument -> pretty_hidden_argum c_name c_call
      | Fundef.Standard_return -> pretty_standard c_name c_call
	  
	  
  let pretty fortran_return fortran_name c_call  =
    let c_name = (String.lowercase fortran_name) ^ "_"
    in
      match fortran_return with
	| Bg.SUBROUTINE -> pretty_void c_name c_call
	| Bg.FUNCTION Bg.S_type -> pretty_standard c_name c_call
	| Bg.FUNCTION Bg.D_type -> pretty_standard c_name c_call
	| Bg.FUNCTION Bg.C_type -> pretty_complex c_name c_call 
	| Bg.FUNCTION Bg.Z_type -> pretty_complex c_name c_call 
	| Bg.FUNCTION Bg.I_type -> pretty_standard c_name c_call
	| Bg.FUNCTION _ -> raise (Bad_function_match "FUNCTION ???")
end
  
module C_return =
struct
  exception Bad_function_match of string 
    
  let out_complex _ =
    "\tv_result = alloc_small(2 * Double_wosize, Double_array_tag);\n" ^
      "\tStore_double_field(v_result, 0, creal(result));\n" ^
      "\tStore_double_field(v_result, 1, cimag(result));\n" 
      
  let out return_type = (* return sentence *)
    match return_type with
      | Bg.SUBROUTINE -> "\tv_result = Val_unit;\n"
      | Bg.FUNCTION Bg.S_type -> "\tv_result = caml_copy_double ((double) result);\n"
      | Bg.FUNCTION Bg.D_type -> "\tv_result = caml_copy_double (result);\n"
      | Bg.FUNCTION Bg.C_type -> 
	  "\tv_result = alloc_small(2 * Double_wosize, Double_array_tag);\n" ^
	    "\tStore_double_field(v_result, 0, (double) crealf (result));\n" ^
	    "\tStore_double_field(v_result, 1, (double) cimagf (result));\n" 
      | Bg.FUNCTION Bg.Z_type -> 
	  "\tv_result = alloc_small(2 * Double_wosize, Double_array_tag);\n" ^
	    "\tStore_double_field(v_result, 0, creal (result));\n" ^
	    "\tStore_double_field(v_result, 1, cimag (result));\n" 
      | Bg.FUNCTION Bg.I_type -> "\tv_result = caml_copy_nativeint (result);\n"
      | Bg.FUNCTION _ -> raise (Bad_function_match "Bg.FUNCTION ???")
end
  

let (input_fundefs, input_argums) = Fundef.read ()
  
let psfas_list = Bg1.make_fundef_list input_fundefs
let argum_map = Bg1.make_argum_map input_argums
  
let _ = if debug then Debug_bg1.pring_argum_map argum_map
let _ = Control.control_argums psfas_list argum_map
let function_structures_list = Bg2.make_function_structures_list argum_map psfas_list




(** Now we have a map of arguments. For each argument, we can know
  - input/output : I, O or IO argument
  - type : - I : input integer
           - CHAR : input char
           - T : standard type
           - t : array of standard type  
  - map of exceptions for type
*)

(****** Construction from the [function_structures_list] *)

let _ = if debug then Pseudo.out function_structures_list

exception Bad_function_match of string 
    
let make_c_native_name fortran_name =
  "octi_raw_blas_" ^ (String.lowercase fortran_name)

let make_ocaml_argum argums_list =
  List.fold_left Ocaml_argument.append "" argums_list

let make_c_declare argums_list =
  List.fold_left C_value_declaration.append "" argums_list

let make_c_assign argums_list =
  List.fold_left C_assignment.append "" argums_list

let make_c_call argums_list =
  List.fold_left C_call.append "" argums_list

let ocaml_return_of_type t =
  match t with
    | Bg.SUBROUTINE -> "unit"
    | Bg.FUNCTION Bg.S_type    -> "float"
    | Bg.FUNCTION Bg.D_type    -> "float"
    | Bg.FUNCTION Bg.C_type    -> "Complex.t"
    | Bg.FUNCTION Bg.Z_type    -> "Complex.t"
    | Bg.FUNCTION Bg.I_type    -> "int"
    | Bg.FUNCTION Bg.CHAR_type -> "int"

let construct_ocaml_code fortran_return fortran_name ocaml_name argums_list =
  "    external " ^ ocaml_name ^ " :" ^ (make_ocaml_argum argums_list) ^
    " " ^ (ocaml_return_of_type fortran_return) ^ " = " ^
    (if (List.length argums_list > 5) then
       " \"" ^ (make_c_native_name fortran_name) ^ "_bytecode\""
     else
       "") ^
    "\"" ^ (make_c_native_name fortran_name) ^ "\"" ^
    "\n"
      
let make_c_argums argums_list =
  let add_c_argum string argum =
    let argum_name = "value v_" ^ (fst argum)
    in
      if (String.length string) <> 0 then string ^ ", " ^ argum_name else argum_name
  in
    List.fold_left add_c_argum "" argums_list

let make_c_camlprim fortran_name argums_list =
  "\nCAMLprim value " ^ (make_c_native_name fortran_name) ^ " (" ^ (make_c_argums argums_list) ^ ") {\n"

let make_c_camlparam argums_list =
  let add_val_argums string argum =
    string ^ "\tCAMLxparam1 (v_" ^ (fst argum) ^ ");\n"
  in
    List.fold_left add_val_argums "\tCAMLparam0 ();\n" argums_list
  
let make_c_camllocal result =
  "\tCAMLlocal1 (" ^ result ^ ");\n"

let make_c_name fortran_name =
  String.lowercase fortran_name

let construct_c_code_for_bytecode fortran_name argums_list =
  let add_argv s i =
    if i > 0 then
      s ^ ", argv[" ^ (string_of_int i) ^ "]"
    else
      "argv[0]"
  in let rec next_argv s imax i =
      if i > imax then
	s
      else
	next_argv (add_argv s i) imax (i+1)
  in let args = next_argv "" ((List.length argums_list) - 1) 0
  in "\nCAMLprim value " ^
       (make_c_native_name fortran_name) ^ "_bytecode (value * argv, int * argn) {\n" ^
       "\treturn " ^ (make_c_native_name fortran_name) ^ " (" ^ args ^ ");\n}\n"  
    

let make_result_declare fortran_return =
    match fortran_return with
    | Bg.SUBROUTINE -> ""
    | Bg.FUNCTION Bg.S_type -> "\tfloat result;\n"
    | Bg.FUNCTION Bg.D_type -> "\tdouble result;\n"
    | Bg.FUNCTION Bg.C_type -> "\t_Complex float result;\n" 
    | Bg.FUNCTION Bg.Z_type -> "\t_Complex double result;\n"
    | Bg.FUNCTION Bg.I_type -> "\tint result;\n"
    | Bg.FUNCTION _ -> raise (Bad_function_match "Bg.FUNCTION ???")


let construct_c_code fortran_return fortran_name argums_list = "" ^
  (C_extern_declare.out fortran_return fortran_name argums_list) ^
  (make_c_camlprim (make_c_name fortran_name) argums_list) ^
  (make_c_camlparam argums_list) ^
  (make_c_camllocal "v_result") ^
  "\n" ^
  (make_c_declare argums_list) ^
  (make_result_declare fortran_return) ^
  "\n" ^
  (make_c_assign argums_list) ^
  "\n" ^
  (C_call.pretty fortran_return fortran_name (make_c_call argums_list)) ^
  "\n" ^
  (C_return.out fortran_return) ^
  "\tCAMLreturn (v_result);\n}\n" ^
  if (List.length argums_list) <= 5 then "" else
    (construct_c_code_for_bytecode fortran_name argums_list)
      
let make_code function_structures_list =
  let append_strings (ss, ds, cs, zs, ccs)
      (fortran_name, (ocaml_group, ocaml_name), fortran_return, argums_list) =
    let ocaml_code = construct_ocaml_code fortran_return fortran_name ocaml_name argums_list
    and c_code = construct_c_code fortran_return fortran_name argums_list
    in match ocaml_group with
      | Bg.S_group -> (ss ^ ocaml_code, ds, cs, zs, ccs ^ c_code)
      | Bg.D_group -> (ss, ds ^ ocaml_code, cs, zs, ccs ^ c_code)
      | Bg.C_group -> (ss, ds, cs ^ ocaml_code, zs, ccs ^ c_code)
      | Bg.Z_group -> (ss, ds, cs, zs ^ ocaml_code, ccs ^ c_code)
  in
    List.fold_left append_strings ("","","","","") function_structures_list
      
let (ss, ds, cs, zs, ccs) = make_code function_structures_list

let ocaml_mli_file = Pervasives.open_out "octi_rawblas.mli"
let ocaml_ml_file  = Pervasives.open_out "octi_rawblas.ml"
let c_file         = Pervasives.open_out "octi_rawblas_stubs.c"

let _ = output_string ocaml_mli_file "(* automatically generated, DO NOT EDIT *)\n"
let _ = output_string ocaml_ml_file  "(* automatically generated, DO NOT EDIT *)\n"
let _ = output_string c_file         "/* automatically generated, DO NOT EDIT */\n"

let _ = output_string ocaml_mli_file ("  module S :
  sig
" ^ ss ^
"  end\n\n")
let _ = output_string ocaml_ml_file ("  module S =
  struct
" ^ ss ^
"  end\n\n")

let _ = output_string ocaml_mli_file ("  module D :
  sig
" ^ ds ^
"  end\n\n")
let _ = output_string ocaml_ml_file ("  module D =
  struct
" ^ ds ^
"  end\n\n")

let _ = output_string ocaml_mli_file ("  module C :
  sig
" ^ cs ^
"  end\n\n")
let _ = output_string ocaml_ml_file ("  module C =
  struct
" ^ cs ^
"  end\n\n")

let _ = output_string ocaml_mli_file ("  module Z :
  sig
" ^ zs ^
"  end\n\n")
let _ = output_string ocaml_ml_file ("  module Z =
  struct
" ^ zs ^
"  end\n\n")

let _ = output_string c_file ("#include <complex.h>
#include <caml/mlvalues.h>
#include <caml/memory.h>
#include <caml/alloc.h>
#include <caml/custom.h>
#include \"octi_rawb.h\"
" ^ ccs)

let _ = close_out ocaml_mli_file
let _ = close_out ocaml_ml_file
let _ = close_out c_file

let _ = print_string "\nOK\n"
